home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1998 November: Tool Chest / Dev.CD Nov 98 TC.toast / Sample Code / Snippets / Printing / Stylemap / StyleMap.p < prev    next >
Encoding:
Text File  |  1992-07-15  |  4.5 KB  |  177 lines  |  [TEXT/PJMM]
  1. program StyleMap;  { Quick and dirty (Think Pascal 3) --  jm (MacDTS), Sept.13, 1991 }
  2.     var
  3.         gWP: WindowPtr;
  4.  
  5.  
  6. {------------------------------------------------}
  7.     procedure InitMac;
  8.     begin
  9.         InitGraf(@thePort);
  10.         InitFonts;
  11.         FlushEvents(everyEvent, 0);
  12.         InitWindows;
  13.         InitMenus;
  14.         TEInit;
  15.         InitDialogs(nil);
  16.         InitCursor;
  17.     end;
  18.  
  19. {------------------------------------------------}
  20.     procedure InitApp;
  21.         var
  22.             bounds: Rect;
  23.     begin
  24.         SetRect(bounds, 0, 0, 480, 290);
  25.         gWP := NewWindow(nil, bounds, 'Click Mouse to Continue', false, documentProc, WindowPtr(-1), false, 0);
  26.         SetPort(gWP);
  27.         MoveWindow(gWP, 10, 50, true);
  28.         ShowWindow(gWP);
  29.     end;
  30.  
  31. {------------------------------------------------}
  32.     procedure WaitForButton;
  33.         var
  34.             evt: EventRecord;
  35.             done: Boolean;
  36.     begin
  37.         done := false;
  38.         repeat
  39.             SystemTask;
  40.             if GetNextEvent(keyDownMask + mDownMask, evt) then
  41.                 done := (evt.what = mouseDown);
  42.         until done;
  43.     end;
  44.  
  45. {========================================}
  46.     function CompressStyle (aStyle: Style): Integer;  { LaserWriter Reference, p. 32 }
  47.         var
  48.             styleCode: Integer;
  49.     begin
  50.         styleCode := 0;
  51.         if bold in aStyle then
  52.             styleCode := styleCode + 1;
  53.         if italic in aStyle then
  54.             styleCode := styleCode + 2;
  55.         if outline in aStyle then
  56.             styleCode := styleCode + 4;
  57.         if shadow in aStyle then
  58.             styleCode := styleCode + 8;
  59.         if condense in aStyle then
  60.             styleCode := styleCode + 16;
  61.         if extend in aStyle then
  62.             styleCode := styleCode + 32;
  63.         CompressStyle := styleCode;  { values 0..47 only: condense/extend mutually exclusive }
  64.     end;
  65.  
  66.  
  67. {------------------------------------------------}
  68.     function BuildPSFontName (id: Integer; aStyle: Style): Str255;
  69.         label
  70.             99;
  71.         type
  72.             IntegerPtr = ^Integer;
  73.             FamRecPtr = ^FamRec;
  74.             StylMapTable = record  { see LaserWriter Reference p. 28 }
  75.                     class: Integer;
  76.                     offset: Longint;
  77.                     reserved: Longint;
  78.                     suffixIndex: packed array[0..47] of SignedByte;
  79.                 end;
  80.             StylMapPtr = ^StylMapTable;
  81.         var
  82.             h: Handle;
  83.             p: FamRecPtr;
  84.             offSet: Integer;
  85.             smp: StylMapPtr;
  86.             q: Ptr;  { pointer to Style-name table: not a good Pascal structure ...}
  87.             nbOfStrings: Integer;  { not used }
  88.             PSName, suffixIndices: Str255;
  89.             lg: Integer; { Stringlength }
  90.             i, whichIndex: Integer;
  91.  
  92.         function NthStyleName (index: Integer; q: Ptr): Str255;
  93. { index 1 => basename, pointed to by q }
  94. { cf.  d e v e l o p  Summer 91, p. 100 ! }
  95.             var
  96.                 s: Str255;
  97.         begin
  98.             if (index > 1) and (index <= nbOfStrings) then
  99.                 begin
  100.                     while index > 1 do
  101.                         begin
  102.                             q := Ptr(ord4(q) + q^ + 1);  { assumes q^ = stringlength < 128 ...}
  103.                             index := index - 1;
  104.                         end;
  105.                     BlockMove(q, @s[0], q^ + 1); { assumes q^ = stringlength < 127 ...}
  106.                     NthStyleName := s;
  107.                 end
  108.             else  { FOND corrupted !}
  109.                 NthStyleName := '???';
  110.         end;
  111.  
  112.     begin  {BuildPSFontName}
  113.         PSName := '';
  114.         TextFace(aStyle);
  115.         h := GetResource('FOND', id);
  116.         if h = nil then
  117.             goto 99;  { a reminiscence of AppleSoft }
  118.         HLock(h);
  119.         p := FamRecPtr(h^);
  120.         offSet := p^.ffStylOff;
  121.         if offSet = 0 then  { no style-mapping table }
  122.             goto 99;  { again ?! }
  123.         smp := StylMapPtr(ord4(p) + offSet);
  124.         q := Ptr(ord4(smp) + SizeOf(StylMapTable));  { style-name table follows style-mappingTable}
  125.         nbOfStrings := IntegerPtr(q)^;   { for range checking in "NthStyleName" above }
  126.         q := Ptr(ord4(q) + 2); { now pointing to basename of font }
  127.         BlockMove(q, @PSName, q^ + 1);  { basename of font; assumes length < 128 }
  128.         whichIndex := smp^.suffixIndex[CompressStyle(aStyle)];
  129.         if whichIndex > 1 then
  130.             begin
  131.                 suffixIndices := NthStyleName(whichIndex, q);
  132.                 for i := 1 to ord(suffixIndices[0]) do
  133.                     PSName := concat(PSName, NthStyleName(ord(suffixIndices[i]), q));
  134.             end;
  135.         HUnlock(h);
  136. 99:
  137.         BuildPSFontName := PSName;
  138.     end;  {BuildPSFontName}
  139.  
  140.  
  141. {------------------------------------------------}
  142.     procedure Test;
  143.         var
  144.             fontName: Str255;
  145.             familyID: Integer;
  146.             aStyle: Style;
  147.     begin
  148.         fontName := 'Times';
  149.         GetFNum(fontName, familyID);
  150.         TextFont(familyID);
  151.         TextSize(36);
  152.  
  153.         aStyle := [];  { plain }
  154.         MoveTo(30, 60);
  155.         DrawString(BuildPSFontName(familyID, aStyle));
  156.  
  157.         aStyle := [bold];
  158.         MoveTo(30, 120);
  159.         DrawString(BuildPSFontName(familyID, aStyle));
  160.  
  161.         aStyle := [italic];
  162.         MoveTo(30, 180);
  163.         DrawString(BuildPSFontName(familyID, aStyle));
  164.  
  165.         aStyle := [bold, italic];
  166.         MoveTo(30, 240);
  167.         DrawString(BuildPSFontName(familyID, aStyle));
  168.     end;
  169.  
  170. {------------------------------------------------}
  171. begin
  172.     InitMac;
  173.     InitApp;
  174.     Test;
  175.     WaitForButton;
  176. end.
  177. {------------------------------------------------}